Cream of the Crop 26/Cream of the Crop 26.iso/program/fpkpas92.zip/SRCRTL.ZIP/RTL/DOS/GO32.PP

Text File | 1997-07-01 | 20KB | 751 lines

{****************************************************************************

                      Copyright (c) 1996 by Florian Klaempfl

 ****************************************************************************}

{
  this unit is part of the FPKPascal run time library
  and implements some stuff for protected mode programming

  History:
       6th november 1996:
         + dosmem* implemented
}

unit go32;

  interface

    const
       { contants for the run modes returned by get_run_mode }
       rm_unknown = 0;
       { raw (without HIMEM) }
       rm_raw = 1;
       { XMS (for example with HIMEM, without EMM386) }
       rm_xms = 2;
       { VCPI (for example HIMEM and EMM386) }
       rm_vcpi = 3;
       { DPMI (for example DOS box or 386Max) }
       rm_dpmi = 4;

    type
       tmeminfo = record
          available_memory : longint;
          available_pages : longint;
          available_lockable_pages : longint;
          linear_space : longint;
          unlocked_pages : longint;
          available_physical_pages : longint;
          total_physical_pages : longint;
          free_linear_space : longint;
          max_pages_in_paging_file : longint;
          reserved : array[0..2] of longint;
       end;

       tseginfo = record
          offset : pointer;
          segment : word;
       end;

       registers=record
          case integer of
           0 : (di,ff1,si,ff2,bp,ff3,ff4,ff5,bx,ff6,dx,ff7,cx,
                ff8,ax,ff9,flags,es,ds,fs,gs,ip,cs,sp,ss : word);
           1 : (edi,esp,ebp,res : longint;
               bl,bh,ff10,ff11,dl,dh,ff12,ff13,
               cl,ch,ff14,ff15,al,ah : byte);
           2 : (realedi,realesi,realebp,realres,
                realebx,realedx,realecx,realeax : longint;
                realflags,
                reales,realds,realfs,realgs,
                realip,realcs,realsp,realss : word);
           3 : (bisedi,bisesi,bisebp,bisres,
                ebx,edx,ecx,eax : longint);
           end;

       trealregs=registers;
       {
          realedi,realesi,realebp,realres,
          realebx,realedx,realecx,realeax : longint;

          realflags,
          reales,realds,realfs,realgs,
          realip,realcs,realsp,realss : word;
       end; }

    const carryflag = 1;
      parityflag = 4;
      auxcarryflag = $10;
      zeroflag = $40;
      signflag = $80;
      trapflag = $100;
      interruptflag = $200;
      directionflag = $400;
      overflowflag = $800;

    { this works only with real DPMI }
    function allocate_ldt_descriptors(count : word) : word;
    procedure free_ldt_descriptor(d : word);
    function segment_to_descriptor(seg : word) : word;
    function get_next_selector_increment_value : word;
    function get_segment_base_address(d : word) : longint;
    procedure set_segment_base_address(d : word;s : longint);
    procedure set_segment_limit(d : word;s : longint);
    function create_code_segment_alias_descriptor(seg : word) : word;
    function get_linear_addr(phys_addr : longint;size : longint) : longint;
    function get_segment_limit(d : word) : longint;
    procedure realintr(intnr : word;var regs : trealregs);

    { is needed for functions which need a real mode buffer }
    function  global_dos_alloc(bytes : longint) : longint;
    procedure global_dos_free(selector : word);

    var
       { selector for the DOS memory (only usable if in DPMI mode) }
       dosmemselector : word;

    { this procedure copies data where the source and destination }
    { are specified by 48 bit pointers                            }
    { Note: the procedure checks only for overlapping if          }
    { source selector=destination selector                        }
    procedure seg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);

    { fills a memory area specified by a 48 bit pointer with c }
    procedure seg_fillchar(seg : word;ofs : longint;count : longint;c : char);
    procedure seg_fillword(seg : word;ofs : longint;count : longint;w : word);

    {************************************}
    { this works with all PM interfaces: }
    {************************************}

    procedure get_meminfo(var meminfo : tmeminfo);
    procedure get_pm_interrupt(vector : byte;var intaddr : tseginfo);
    procedure set_pm_interrupt(vector : byte;const intaddr : tseginfo);
    function get_cs : word;
    function get_ds : word;
    function get_ss : word;

    { disables and enables interrupts }
    procedure disable;
    procedure enable;

    function inportb(port : word) : byte;
    function inportw(port : word) : word;
    function inportl(port : word) : longint;

    procedure outportb(port : word;data : byte);
    procedure outportw(port : word;data : word);
    procedure outportl(port : word;data : longint);
    function get_run_mode : word;

{$ifdef GO32V2}
    function transfer_buffer : longint;
    function tb_size : longint;
    procedure copytodos(var addr; len : longint);
    procedure copyfromdos(var addr; len : longint);
{$endif GO32V2}

   var
       { this procedures are assigned to the procedure which are needed }
       { for the current mode to access DOS memory                      }
       { It's strongly recommended to use this procedures!              }
       dosmemput : procedure(seg : word;ofs : word;var data;count : longint);
       dosmemget : procedure(seg : word;ofs : word;var data;count : longint);
       dosmemmove : procedure(sseg,sofs,dseg,dofs : word;count : longint);
       dosmemfillchar : procedure(seg,ofs : word;count : longint;c : char);
       dosmemfillword : procedure(seg,ofs : word;count : longint;w : word);

  implementation

    { the following procedures copy from and to DOS memory without DPMI }
    procedure raw_dosmemput(seg : word;ofs : word;var data;count : longint);

      begin
         move(data,pointer($e0000000+seg*16+ofs)^,count);
      end;

    procedure raw_dosmemget(seg : word;ofs : word;var data;count : longint);

      begin
         move(pointer($e0000000+seg*16+ofs)^,data,count);
      end;

    procedure raw_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);

      begin
         move(pointer($e0000000+sseg*16+sofs)^,pointer($e0000000+dseg*16+dofs)^,count);
      end;

    procedure raw_dosmemfillchar(seg,ofs : word;count : longint;c : char);

      begin
         fillchar(pointer($e0000000+seg*16+ofs)^,count,c);
      end;

    procedure raw_dosmemfillword(seg,ofs : word;count : longint;w : word);

      begin
         fillword(pointer($e0000000+seg*16+ofs)^,count,w);
      end;

    { the following procedures copy from and to DOS memory using DPMI }
    procedure dpmi_dosmemput(seg : word;ofs : word;var data;count : longint);

      begin
         seg_move(get_ds,longint(@data),dosmemselector,seg*16+ofs,count);
      end;

    procedure dpmi_dosmemget(seg : word;ofs : word;var data;count : longint);

      begin
         seg_move(dosmemselector,seg*16+ofs,get_ds,longint(@data),count);
      end;

    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);

      begin
         seg_move(dosmemselector,sseg*16+sofs,dosmemselector,dseg*16+dofs,count);
      end;

    procedure dpmi_dosmemfillchar(seg,ofs : word;count : longint;c : char);

      begin
         seg_fillchar(dosmemselector,seg*16+ofs,count,c);
      end;

    procedure dpmi_dosmemfillword(seg,ofs : word;count : longint;w : word);

      begin
         seg_fillword(dosmemselector,seg*16+ofs,count,w);
      end;

    function global_dos_alloc(bytes : longint) : longint;

      begin
         asm
            movl bytes,%ebx
            orl  $0x10,%ebx             // round up
            shrl $0x4,%ebx              // convert to Paragraphs
            movw $0x100,%ax             // function 0x100
            int  $0x31
            shll $0x10,%eax             // return Segment in hi(Result)
            movw %dx,%ax                // return Selector in lo(Result)
            movl %eax,__result
         end;
      end;

    procedure  global_dos_free(selector : word);

      begin
         asm
            movw Selector,%dx
            movw $0x101,%ax
            int  $0x31
         end;
      end;

    procedure realintr(intnr : word;var regs : trealregs);

      begin
     regs.realsp:=0;
     regs.realss:=0;
         asm
            movw  intnr,%bx
            xorl  %ecx,%ecx
            movl  regs,%edi

            // es is always equal ds
            movw  $0x300,%ax
            int   $0x31
         end;
      end;

    procedure seg_fillchar(seg : word;ofs : longint;count : longint;c : char);

      begin
         asm
            movl ofs,%edi
            movl count,%ecx
            movb c,%dl
            { load es with selector }
            pushw %es
            movw seg,%ax
            movw %ax,%es
            { fill eax with duplicated c }
            { so we can use stosl        }
            movb %dl,%dh
            movw %dx,%ax
            shll $16,%eax
            movw %dx,%ax
            movl %ecx,%edx
            shrl $2,%ecx
            cld
            rep
            stosl
            movl %edx,%ecx
            andl $3,%ecx
            rep
            stosb
            popw %es
         end ['EAX','ECX','EDX','EDI'];
      end;

    procedure seg_fillword(seg : word;ofs : longint;count : longint;w : word);

      begin
         asm
            movl ofs,%edi
            movl count,%ecx
            movw w,%dx
            { load segment }
            pushw %es
            movw seg,%ax
            movw %ax,%es
            { fill eax }
            movw %dx,%ax
            shll $16,%eax
            movw %dx,%ax
            movl %ecx,%edx
            shrl $1,%ecx
            cld
            rep
            stosl
            movl %edx,%ecx
            andl $1,%ecx
            rep
            stosw
            popw %es
         end ['EAX','ECX','EDX','EDI'];
      end;

    procedure seg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);

      begin
         if count=0 then
           exit;
         if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
           asm
              pushw %es
              pushw %ds
              cld
              movl count,%ecx
              movl source,%esi
              movl dest,%edi
              movw dseg,%ax
              movw %ax,%es
              movw sseg,%ax
              movw %ax,%ds
              movl %ecx,%eax
              shrl $2,%ecx
              rep
              movsl
              movl %eax,%ecx
              andl $3,%ecx
              rep
              movsb
              popw %ds
              popw %es
           end ['ESI','EDI','ECX','EAX']
         else if (source<dest) then
           { copy backward for overlapping }
           asm
              pushw %es
              pushw %ds
              std
              movl count,%ecx
              movl source,%esi
              movl dest,%edi
              movw dseg,%ax
              movw %ax,%es
              movw sseg,%ax
              movw %ax,%ds
              addl %ecx,%esi
              addl %ecx,%edi
              movl %ecx,%eax
              andl $3,%ecx
              orl %ecx,%ecx
              jz LSEG_MOVE1

              { calculate esi and edi}
              decl %esi
              decl %edi
              rep
              movsb
              incl %esi
              incl %edi
           LSEG_MOVE1:
              subl $4,%esi
              subl $4,%edi
              movl %eax,%ecx
              shrl $2,%ecx
              rep
              movsl
              cld
              popw %ds
              popw %es
           end ['ESI','EDI','ECX'];
      end;

    procedure outportb(port : word;data : byte);

      begin
         asm
            movw port,%dx
            movb data,%al
            outb %al,%dx
         end ['EAX','EDX'];
      end;

    procedure outportw(port : word;data : word);

      begin
         asm
            movw port,%dx
            movw data,%ax
            outw %ax,%dx
         end ['EAX','EDX'];
      end;

    procedure outportl(port : word;data : longint);

      begin
         asm
            movw port,%dx
            movl data,%eax
            outl %eax,%dx
         end ['EAX','EDX'];
      end;

    function inportb(port : word) : byte;

      begin
         asm
            movw port,%dx
            inb %dx,%al
            movb %al,__RESULT
         end ['EAX','EDX'];
      end;

    function inportw(port : word) : word;

      begin
         asm
            movw port,%dx
            inw %dx,%ax
            movw %ax,__RESULT
         end ['EAX','EDX'];
      end;

    function inportl(port : word) : longint;

      begin
         asm
            movw port,%dx
            inl %dx,%eax
            movl %eax,__RESULT
         end ['EAX','EDX'];
      end;

    function get_cs : word;

      begin
         asm
            movw %cs,%ax
            movw %ax,__RESULT;
         end;
      end;


    function get_ss : word;

      begin
         asm
            movw %ss,%ax
            movw %ax,__RESULT;
         end;
      end;

    function get_ds : word;

      begin
         asm
            movw %ds,%ax
            movw %ax,__RESULT;
         end;
      end;

    procedure set_pm_interrupt(vector : byte;const intaddr : tseginfo);

      begin
         asm
            movl intaddr,%eax
            movl (%eax),%edx
            movw 4(%eax),%cx
            movw $0x205,%ax
            movb vector,%bl
            int $0x31
         end;
      end;

    procedure get_pm_interrupt(vector : byte;var intaddr : tseginfo);

      begin
         asm
            movb vector,%bl
            movw $0x204,%ax
            int $0x31
            movl intaddr,%eax
            movl %edx,(%eax)
            movw %cx,4(%eax)
         end;
      end;

    function allocate_ldt_descriptors(count : word) : word;

      begin
         asm
            movw count,%cx
            movw $0,%ax
            int $0x31
            movw %ax,__RESULT
         end;
      end;

    procedure free_ldt_descriptor(d : word);

      begin
         asm
             movw d,%bx
             movw $1,%ax
             int $0x31
      end;
       end;

    function segment_to_descriptor(seg : word) : word;

      begin
         asm
             movw seg,%bx
             movw $2,%ax
             int $0x31
             movw %ax,__RESULT
      end;
       end;

    function get_next_selector_increment_value : word;

      begin
         asm
             movw $3,%ax
             int $0x31
             movw %ax,__RESULT
      end;
       end;

    function get_segment_base_address(d : word) : longint;

      begin
         asm
            movw d,%bx
            movw $6,%ax
            int $0x31
            xorl %eax,%eax
            movw %dx,%ax
            shll $16,%ecx
            orl %ecx,%eax
            movl %eax,__RESULT
         end;
      end;

    procedure set_segment_base_address(d : word;s : longint);

      begin
         asm
            movw d,%bx
            leal s,%eax
            movw (%eax),%dx
            movw 2(%eax),%cx
            movw $7,%ax
            int $0x31
         end;
      end;

    procedure set_segment_limit(d : word;s : longint);

      begin
         asm
            movw d,%bx
            leal s,%eax
            movw (%eax),%dx
            movw 2(%eax),%cx
            movw $8,%ax
            int $0x31
         end;
      end;

   function get_segment_limit(d : word) : longint;

      begin
         asm
            movzwl d,%eax
            lsl %eax,%eax
            jz L_ok
            xorl %eax,%eax
         L_ok:
            movl %eax,__RESULT
         end;
      end;
    function create_code_segment_alias_descriptor(seg : word) : word;

      begin
         asm
             movw seg,%bx
             movw $0xa,%ax
             int $0x31
             movw %ax,__RESULT
      end;
       end;

    procedure get_meminfo(var meminfo : tmeminfo);

      begin
         asm
            movl meminfo,%edi
            movw $0x500,%ax
            int $0x31
         end;
      end;

    function get_linear_addr(phys_addr : longint;size : longint) : longint;

      begin
         asm
            movl phys_addr,%ebx
            movl %ebx,%ecx
            shrl $16,%ebx
            movl phys_addr,%esi
            movl %esi,%edi
            shrl $16,%esi
            movw $0x800,%ax
            int $0x31
            shll $16,%ebx
            movw %cx,%bx
            movl %ebx,__RESULT
         end;
      end;

    procedure disable;

      begin
         asm
            cli;
         end;
      end;

    procedure enable;

      begin
         asm
            sti;
         end;
      end;

    function get_run_mode : word;

      begin
         asm
            movw _run_mode,%ax
            movw %ax,__RESULT
         end ['EAX'];
      end;
{
typedef struct {
  unsigned long handle;            /* 0, 2 */
  unsigned long size;     /* or count */    /* 4, 6 */
  unsigned long address;        /* 8, 10 */
} __dpmi_meminfo;
    procedure map_device_in_memory_block(const meminfo : tmeminfo;
      phys_addr : longint);

      begin
         asm
        movl meminfo,%eax
            movl (%eax),%esi
        movl 4(%eax),%ecx
        movl 8(%eax),%ebx
        movl phys_addr,%edx
            movw $0x508,%ax
            int $0x31
         end;
      end;
}

    function get_core_selector : word;

      begin
         asm
            movw _core_selector,%ax
            movw %ax,__RESULT
         end;
      end;

{$ifdef GO32V2}

    function transfer_buffer : longint;
    begin
    transfer_buffer := go32_info_block.linear_address_of_transfer_buffer;
{       asm
       leal __go32_info_block,%ebx
       movl 12(%ebx),%eax
       leave
       ret
       end ['EAX','EBX'];}
    end;

    function tb_size : longint;
    begin
    tb_size := go32_info_block.size_of_transfer_buffer;
{       asm
       leal __go32_info_block,%ebx
       movl 16(%ebx),%eax
       leave
       ret
       end ['EAX','EBX'];}
    end;

     procedure copytodos(var addr; len : longint);
     begin
        if len > tb_size then runerror(200);
        seg_move(get_ds,longint(@addr),dosmemselector,transfer_buffer,len);
     end;

     procedure copyfromdos(var addr; len : longint);
     begin
        if len > tb_size then runerror(200);
        seg_move(dosmemselector,transfer_buffer,get_ds,longint(@addr),len);
     end;

{$endif GO32V2}

begin
   if get_run_mode=rm_dpmi then
     begin
        dosmemget:=@dpmi_dosmemget;
        dosmemput:=@dpmi_dosmemput;
        dosmemmove:=@dpmi_dosmemmove;
        dosmemfillchar:=@dpmi_dosmemfillchar;
        dosmemfillword:=@dpmi_dosmemfillword;
        dosmemselector:=get_core_selector;
     end
   else
     begin
        dosmemget:=@raw_dosmemget;
        dosmemput:=@raw_dosmemput;
        dosmemmove:=@raw_dosmemmove;
        dosmemfillchar:=@raw_dosmemfillchar;
        dosmemfillword:=@raw_dosmemfillword;
     end;
end.